\ W32FHarness.fth - FCOM portability harness for Win32Forth
\ Tom Dixon
\ 9/15/2008

SYS-WARNING-OFF

\ **** Error Handling ****

-500 CONSTANT err_NotDispatch
-501 CONSTANT err_InvBind
-502 CONSTANT err_Bind
-503 CONSTANT err_GetTypeInfo
-504 CONSTANT err_GetDoc
-505 CONSTANT err_LoadTypeLib
-506 CONSTANT err_GetTypeComp
-507 CONSTANT err_NoVI
-508 CONSTANT err_NotIF
-509 CONSTANT err_VarStFull
-510 CONSTANT err_CantDispatch
-511 CONSTANT err_NoProgID
-512 CONSTANT err_NoIUnknown
-513 CONSTANT err_NoValStruct

-514 CONSTANT err_BadAlloc

-515 CONSTANT err_GUIDlen
-516 CONSTANT err_BadCLSID

-517 CONSTANT err_IUnknown
-518 CONSTANT err_AXcreate
-519 CONSTANT err_noIF


THROW_MSGS LINK, err_NotDispatch        , ," Dispatch Interface not returned"
THROW_MSGS LINK, err_InvBind            , ," Invalid Bind Type"
THROW_MSGS LINK, err_Bind               , ," Unable to Bind to type"
THROW_MSGS LINK, err_GetTypeInfo        , ," Unable to get type info"
THROW_MSGS LINK, err_GetDoc             , ," Unable to get Documentation"
THROW_MSGS LINK, err_LoadTypeLib        , ," Error Loading Type Library"
THROW_MSGS LINK, err_GetTypeComp        , ," Error Getting TypeComp"
THROW_MSGS LINK, err_NoVI               , ," No Virtual Interface"
THROW_MSGS LINK, err_NotIF              , ," Not An Interface"
THROW_MSGS LINK, err_VarStFull          , ," Variant Stack Full"
THROW_MSGS LINK, err_CantDispatch       , ," Unable to Call Dispatch"
THROW_MSGS LINK, err_NoProgID           , ," Unable to Find ProgID"
THROW_MSGS LINK, err_NoIUnknown         , ," Unable to Get IUnknown"
THROW_MSGS LINK, err_NoValStruct        , ," Not a valid COM Structure"

THROW_MSGS LINK, err_BadAlloc           , ," Unable to Allocate String"

THROW_MSGS LINK, err_GUIDlen            , ," Invalid Guid Length"
THROW_MSGS LINK, err_BadCLSID           , ," Not a CLSID"

THROW_MSGS LINK, err_IUnknown           , ," Unable to get IUnknown interface"
THROW_MSGS LINK, err_AXcreate           , ," Unable to create ActiveX Control"
THROW_MSGS LINK, err_noIF               , ," Unable to get Interface"



\ **** Windows API Access ****

winlibrary oleaut32.dll
winlibrary ole32.dll
winlibrary atl.dll


\ **** GUID calls ****
: fStringFromCLSID ( ppsz rclsid -- res ) 
   call StringFromCLSID ;

\ **** UNICODE Calls ****
: fMultiByteToWideChar ( wclen *wc mblen *mb flags cp -- int ) 
   call MultiByteToWideChar ;
   
: fWideCharToMultiByte ( *used *def mblen *mb wclen *wc flags cp -- len )
   call WideCharToMultiByte ;
 
: fSysAllocStringLen ( cch pch -- addr ) 
   call SysAllocStringLen ;
   
: fSysFreeString ( bstr -- ) 
   call SysFreeString drop ;

SYNONYM MB>WC fMultiByteToWideChar
SYNONYM WC>MB fWideCharToMultiByte
   
\ **** FCOM calls ****
: fCoInitialize ( n -- res )
   call CoInitialize ;
   
: fCoCreateInstance ( ppv riid context pUnkOuter rclsid -- res )
   call CoCreateInstance ;
   
: fCLSIDFromProgID ( pclsid pprogid -- res )
   call CLSIDFromProgID ;
   
: fLoadRegTypeLib ( pptlib lcid wverminor wvermajor rguid -- res )
   call LoadRegTypeLib ;
   
: fLoadTypeLib ( pptlib szFile -- res ) 
   call LoadTypeLib ;
   
: fCoTaskMemFree ( *pv -- ) 
   call CoTaskMemFree drop ;
   
\ **** ActiveX calls ****

: fAtlAxCreateControl ( ppUnk pstream hWnd lpszName -- res )
   call AtlAxCreateControl ;
   
: fAtlAxGetControl ( pptlib szFile -- res )
   call AtlAxGetControl ;
   
   


\ **** Win32Forth Specific Behavior ****

\ Interface Calling Convention (FCOM.F)

: INTERFACE-CALL ( n1 n2 n3 ... nx a indx ) \ vtable call
   >r @ dup @ r> cells+ @ call-proc ;

: RUN-INTERFACE ( pointer imethod -- ) \ runtime interface call
   cell+ @ interface-call ;

: COMPILE-INTERFACE ( pointer imethod -- ) \ fast compile interface call
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @
   cell+ @ cells POSTPONE LITERAL 
   POSTPONE + 
   POSTPONE @ 
   POSTPONE call-proc ;
  

: RUN-VTABLE ( pointer offset -- ) 
   swap @ dup @ rot + @ call-proc ;

: COMPILE-VTABLE ( pointer offset -- ) 
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @ 
   POSTPONE LITERAL
   POSTPONE + 
   POSTPONE @ 
   POSTPONE call-proc ;

: laddr ( <name> -- addr ) \ returns the address of the local variable
   ['] &OF execute ; IMMEDIATE


: discard-sinline ( -- ) \ flag to compiler inliner (not needed in w32f)
   ; immediate


\ Global searching - This is system specific.

defer COMsearcher ( str len -- flag )

\ Until it gets re-defined
:noname 2drop false ; is COMsearcher 

: (comfind) ( str -- str 0 | cfa flag ) 
   [ action-of find literal ] execute  \ call previous find word
   ?dup 0= if 
     dup count COMsearcher if 
       drop ['] noop 1
     else
       0 
     then
   then ;

' (comfind) is find

: AtCold ( xt -- ) \ adds xt to initialization chain
   Initialization-Chain noop-chain-add ! ;

: AtExit ( xt -- ) \ adds xt to exit chain
   Unload-Chain noop-chain-add ! ;
